home *** CD-ROM | disk | FTP | other *** search
/ Disc to the Future 2 / Disc to the Future Part II Programmer's Reference (Wayzata Technology)(6013)(1992).bin / MAC / MPW_TOOL / TOOLS / TOOLS_WI / ICON_8 / ICONX_FO / INTERP.C < prev    next >
Text File  |  1990-03-02  |  39KB  |  1,691 lines
  1. /*
  2.  * The intepreter proper.
  3.  */
  4.  
  5. #include "::h:config.h"
  6. #include "::h:rt.h"
  7. #include "rproto.h"
  8. #include "::h:opdefs.h"
  9.  
  10. extern fptr fncentry[];
  11.  
  12.  
  13. #ifdef DumpIstream
  14. extern FILE *imons;
  15. #endif                    /* DumpIstream */
  16.  
  17. #ifdef DumpIcount
  18. extern FILE *imonc;
  19. #endif                    /* DumpIcount */
  20.  
  21. /*
  22.  * The following code is operating-system dependent [@interp.01].  Declarations
  23.  *  and include files.
  24.  */
  25.  
  26. #if PORT
  27. Deliberate Syntax Error
  28. #endif                    /* PORT */
  29.  
  30. #if ATARI_ST || HIGHC_386 || MSDOS || MVS || OS2 || UNIX || VM || VMS
  31.    /* nothing needed */
  32. #endif                    /* ATARI_ST || ... */
  33.  
  34. #if AMIGA
  35. #include <fcntl.h>
  36. #include <ios1.h>
  37.  
  38. extern int chkbreak;
  39. #endif                    /* AMIGA */
  40.  
  41. #if MACINTOSH
  42. #if MPW
  43. #include <CursorCtl.h>
  44. #define CURSORINTERVAL 1000
  45. #endif MPW
  46. #endif                                  /* MACINTOSH */
  47.  
  48. /*
  49.  * End of operating-system specific code.
  50.  */
  51.  
  52. #ifdef EvalTrace
  53. extern word lineno;        /* source line number */
  54. extern word colmno;        /* source column number */
  55. #endif                    /* EvalTrace */
  56.  
  57. /*
  58.  * Istate variables.
  59.  */
  60. struct pf_marker *pfp = 0;    /* Procedure frame pointer */
  61. struct ef_marker *efp;        /* Expression frame pointer */
  62. struct gf_marker *gfp;        /* Generator frame pointer */
  63. inst ipc;            /* Interpreter program counter */
  64. dptr argp;            /* Pointer to argument zero */
  65. word *sp = NULL;        /* Stack pointer */
  66.  
  67. #ifdef WATERLOO_C_V3_0
  68. int *cw3defect;
  69. #endif                    /* WATERLOO_C_V3_0 */
  70.  
  71. #ifdef IconCalling
  72. extern int interp_status;    /* interpreter status */
  73. extern int IDepth;        /* depth of icon_call */
  74. #endif                    /* IconCalling */
  75.  
  76. #ifdef Polling
  77. extern int pollctr;
  78. #endif                    /* Polling */
  79.  
  80.  
  81. int ilevel;            /* Depth of recursion in interp() */
  82. word lastop;            /* Last operator evaluated */
  83. struct descrip list_tmp;    /* list argument to Op_Apply */
  84.  
  85.  
  86. #ifdef MaxLevel
  87. int maxilevel;            /* Maximum ilevel */
  88. int maxplevel;            /* Maximum &level */
  89. word *maxsp;            /* Maximum interpreter sp */
  90. #endif                    /* MaxLevel */
  91.  
  92. /*
  93.  * Descriptor to hold result for eret across potential interp unwinding.
  94.  */
  95. struct descrip eret_tmp;
  96.  
  97. /*
  98.  * Last co-expression action.
  99.  */
  100. int coexp_act;
  101.  
  102. #ifdef TraceBack
  103. dptr xargp;
  104. word xnargs;
  105. #endif                    /* TraceBack */
  106.  
  107. /*
  108.  * Macros for use inside the main loop of the interpreter.
  109.  */
  110.  
  111. /*
  112.  * Setup_Op sets things up for a call to the C function for an operator.
  113.  */
  114. #ifdef TraceBack
  115. #define Setup_Op(nargs)  \
  116.    rargp = (dptr)(rsp - 1) - nargs; \
  117.    xargp = rargp; \
  118.    ExInterp;
  119. #else                    /* TraceBack */
  120. #define Setup_Op(nargs)  \
  121.    rargp = (dptr)(rsp - 1) - nargs; \
  122.    ExInterp;
  123. #endif                    /* TraceBack */
  124.  
  125.  
  126. #define Call_Cond if ((*(optab[lastop]))(rargp) == A_Failure) goto efail; \
  127.      else \
  128.      rsp = (word *) rargp + 1;
  129. /*
  130.  * Call_Gen - Call a generator. A C routine associated with the
  131.  *  current opcode is called. When it when it terminates, control is
  132.  *  passed to C_rtn_term to deal with the termination condition appropriately.
  133.  */
  134. #define Call_Gen   signal = (*(optab[lastop]))(rargp); \
  135.      goto C_rtn_term;
  136.  
  137. /*
  138.  * GetWord fetches the next icode word.  PutWord(x) stores x at the current
  139.  * icode word.
  140.  */
  141. #define GetWord (*ipc.opnd++)
  142. #define PutWord(x) ipc.opnd[-1] = (x)
  143. #define GetOp (word)(*ipc.op++)
  144. #define PutOp(x) ipc.op[-1] = (x)
  145. /*
  146.  * DerefArg(n) dereferences the nth argument.
  147.  */
  148. #define DerefArg(n)   if (DeRef(rargp[n]) == Error) {\
  149.    runerr(0, NULL);\
  150.    goto efail;}
  151.  
  152. /*
  153.  * For the sake of efficiency, the stack pointer is kept in a register
  154.  *  variable, rsp, in the interpreter loop.  Since this variable is
  155.  *  only accessible inside the loop, and the global variable sp is used
  156.  *  for the stack pointer elsewhere, rsp must be stored into sp when
  157.  *  the context of the loop is left and conversely, rsp must be loaded
  158.  *  from sp when the loop is reentered.  The macros ExInterp and EntInterp,
  159.  *  respectively, handle these operations.  Currently, this register/global
  160.  *  scheme is only used for the stack pointer, but it can be easily extended
  161.  *  to other variables.
  162.  */
  163.  
  164. #define ExInterp    sp = rsp;
  165. #define EntInterp    rsp = sp;
  166.  
  167. /*
  168.  * Inside the interpreter loop, PushDesc, PushNull, PushAVal, and
  169.  *  PushVal use rsp instead of sp for efficiency.
  170.  */
  171.  
  172. #undef PushDesc
  173. #undef PushNull
  174. #undef PushVal
  175. #undef PushAVal
  176. #define PushDesc(d)   {*++rsp=((d).dword); *++rsp=((d).vword.integr);}
  177. #define PushNull   {*++rsp = D_Null; *++rsp = 0;}
  178. #define PushVal(v)   {*++rsp = (word)(v);}
  179.  
  180. /*
  181.  * The following code is operating-system dependent [@interp.02].  Define
  182.  *  PushAVal for computers that store longs and pointers differently.
  183.  */
  184.  
  185. #if PORT
  186. #define PushAVal(x) PushVal(x)
  187. Deliberate Syntax Error
  188. #endif                    /* PORT */
  189.  
  190. #if MSDOS || OS2
  191. #define PushAVal(x) {rsp++; \
  192.                stkword.stkadr = (char *)(x); \
  193.                *rsp = stkword.stkint; \
  194.                }
  195. #endif                    /* MSDOS || OS2 */
  196.  
  197. #if AMIGA || ATARI_ST || HIGHC_386 || MACINTOSH || MVS || UNIX || VM || VMS
  198. #define PushAVal(x) PushVal(x)
  199. #endif                    /* AMIGA || ATARI_ST || HIGHC_386 ... */
  200.  
  201. /*
  202.  * End of operating-system specific code.
  203.  */
  204.  
  205. /*
  206.  * The main loop of the interpreter.
  207.  */
  208.  
  209. int interp(fsig,cargp)
  210.  
  211. int fsig;
  212. dptr cargp;
  213.    {
  214.    register word opnd;
  215.    register word *rsp;
  216.    register dptr rargp;
  217.    register struct ef_marker *newefp;
  218.    register struct gf_marker *newgfp;
  219.    register word *wd;
  220.    register word *firstwd, *lastwd;
  221.    word *oldsp;
  222.    int type, signal, args;
  223.    extern int (*optab[])();
  224.    extern struct astkblk *alcactiv();
  225.    extern char *strcons;
  226.    struct b_proc *bproc;
  227.  
  228. #ifdef TallyOpt
  229.    extern word tallybin[];
  230. #endif                    /* TallyOpt */
  231.  
  232.  
  233.    /*
  234.     * Make a stab at catching interpreter stack overflow.  This does
  235.     * nothing for invocation in a co-expression other than &main.
  236.     */
  237.    if (BlkLoc(k_current) == BlkLoc(k_main) &&
  238.       ((char *)sp + PerilDelta) > (char *)stackend) 
  239.          fatalerr(-301, NULL);
  240.  
  241. #ifdef Polling
  242.             pollctr--;
  243.             if (!pollctr)
  244.                pollctr = pollevent();
  245. #endif                    /* Polling */
  246.  
  247.    ilevel++;
  248.  
  249. #ifdef MaxLevel
  250.    if (ilevel > maxilevel)
  251.       maxilevel = ilevel;
  252. #endif                    /* MaxLevel */
  253.  
  254.    EntInterp;
  255.    if (fsig == G_Csusp) {
  256.  
  257.  
  258.       oldsp = rsp;
  259.  
  260.       /*
  261.        * Create the generator frame.
  262.        */
  263.       newgfp = (struct gf_marker *)(rsp + 1);
  264.       newgfp->gf_gentype = G_Csusp;
  265.       newgfp->gf_gfp = gfp;
  266.       newgfp->gf_efp = efp;
  267.       newgfp->gf_ipc = ipc;
  268.       rsp += Wsizeof(struct gf_smallmarker);
  269.  
  270.       /*
  271.        * Region extends from first word after the marker for the generator
  272.        *  or expression frame enclosing the call to the now-suspending
  273.        *  routine to the first argument of the routine.
  274.        */
  275.       if (gfp != 0) {
  276.      if (gfp->gf_gentype == G_Psusp)
  277.         firstwd = (word *)gfp + Wsizeof(*gfp);
  278.      else
  279.         firstwd = (word *)gfp + Wsizeof(struct gf_smallmarker);
  280.      }
  281.       else
  282.      firstwd = (word *)efp + Wsizeof(*efp);
  283.       lastwd = (word *)cargp + 1;
  284.  
  285.       /*
  286.        * Copy the portion of the stack with endpoints firstwd and lastwd
  287.        *  (inclusive) to the top of the stack.
  288.        */
  289.       for (wd = firstwd; wd <= lastwd; wd++)
  290.      *++rsp = *wd;
  291.       gfp = newgfp;
  292.       }
  293. /*
  294.  * Top of the interpreter loop.
  295.  */
  296.  
  297.    for (;;) {
  298.  
  299. #ifdef MaxLevel
  300.       if (sp > maxsp)
  301.      maxsp = sp;
  302. #endif                    /* MaxLevel */
  303.  
  304.       lastop = GetOp;        /* Instruction fetch */
  305.  
  306. #ifdef StackPic
  307.       ExInterp;
  308.       stkdump((int)lastop);
  309.       EntInterp;
  310. #endif                    /* StackPic */
  311.  
  312. #ifdef DumpIstream
  313.       putc((char)lastop,imons);
  314. #endif                    /* DumpIstream */
  315.  
  316. #ifdef DumpIcount
  317.       if (lastop > MaxIcode) {
  318.      fprintf(stderr,"Unexpected large opcode = %d\n",lastop);
  319.      fflush(stderr);
  320.      abort;
  321.      }
  322.       icode[lastop]++;
  323. #endif                    /* DumpIcount */
  324.  
  325. /*
  326.  * The following code is operating-system dependent [@interp.03].  Check
  327.  *  for external event.
  328.  */
  329. #if PORT
  330. Deliberate Syntax Error
  331. #endif                    /* PORT */
  332.  
  333. #if AMIGA
  334.       ExInterp;
  335.       if (chkbreak > 0)
  336.      chkabort();            /* check for CTRL-C or CTRL-D break */
  337.       EntInterp;
  338. #endif                    /* AMIGA */
  339.  
  340. #if ATARI_ST || HIGHC_386 || MSDOS || MVS || OS2 || UNIX || VM || VMS
  341.    /* nothing to do */
  342. #endif                    /* ATARI_ST || HIGHC_386 ... */
  343.  
  344. #if MACINTOSH
  345. #if MPW
  346.    {
  347.    static short cursorcount = CURSORINTERVAL;
  348.    if (--cursorcount == 0) {
  349.       RotateCursor(0);
  350.       cursorcount = CURSORINTERVAL;
  351.       }
  352.    }
  353. #endif                    /* MPW */
  354. #endif                    /* MACINTOSH */
  355.  
  356. /*
  357.  * End of operating-system specific code.
  358.  */
  359.  
  360.       switch ((int)lastop) {        /*
  361.                  * Switch on opcode.  The cases are
  362.                  * organized roughly by functionality
  363.                  * to make it easier to find things.
  364.                  * For some C compilers, there may be
  365.                  * an advantage to arranging them by
  366.                  * likelihood of selection.
  367.                  */
  368.  
  369.                 /* ---Constant construction--- */
  370.  
  371.      case Op_Cset:        /* cset */
  372.         PutOp(Op_Acset);
  373.         PushVal(D_Cset);
  374.         opnd = GetWord;
  375.         opnd += (word)ipc.opnd;
  376.         PutWord(opnd);
  377.         PushAVal(opnd);
  378.         break;
  379.  
  380.      case Op_Acset:     /* cset, absolute address */
  381.         PushVal(D_Cset);
  382.         PushAVal(GetWord);
  383.         break;
  384.  
  385.      case Op_Int:        /* integer */
  386.         PushVal(D_Integer);
  387.         PushVal(GetWord);
  388.         break;
  389.  
  390.      case Op_Real:        /* real */
  391.         PutOp(Op_Areal);
  392.         PushVal(D_Real);
  393.         opnd = GetWord;
  394.         opnd += (word)ipc.opnd;
  395.         PushAVal(opnd);
  396.         PutWord(opnd);
  397.         break;
  398.  
  399.      case Op_Areal:     /* real, absolute address */
  400.         PushVal(D_Real);
  401.         PushAVal(GetWord);
  402.         break;
  403.  
  404.      case Op_Str:        /* string */
  405.         PutOp(Op_Astr);
  406.         PushVal(GetWord)
  407.         opnd = (word)strcons + GetWord;
  408.         PutWord(opnd);
  409.         PushAVal(opnd);
  410.         break;
  411.  
  412.      case Op_Astr:        /* string, absolute address */
  413.         PushVal(GetWord);
  414.         PushAVal(GetWord);
  415.         break;
  416.  
  417.                 /* ---Variable construction--- */
  418.  
  419.      case Op_Arg:        /* argument */
  420.         PushVal(D_Var);
  421.         PushAVal(&argp[GetWord + 1]);
  422.         break;
  423.  
  424.      case Op_Global:    /* global */
  425.         PutOp(Op_Aglobal);
  426.         PushVal(D_Var);
  427.         opnd = GetWord;
  428.         PushAVal(&globals[opnd]);
  429.         PutWord((word)&globals[opnd]);
  430.         break;
  431.  
  432.      case Op_Aglobal:    /* global, absolute address */
  433.         PushVal(D_Var);
  434.         PushAVal(GetWord);
  435.         break;
  436.  
  437.      case Op_Local:     /* local */
  438.         PushVal(D_Var);
  439.         PushAVal(&pfp->pf_locals[GetWord]);
  440.         break;
  441.  
  442.      case Op_Static:    /* static */
  443.         PutOp(Op_Astatic);
  444.         PushVal(D_Var);
  445.         opnd = GetWord;
  446.         PushAVal(&statics[opnd]);
  447.         PutWord((word)&statics[opnd]);
  448.         break;
  449.  
  450.      case Op_Astatic:    /* static, absolute address */
  451.         PushVal(D_Var);
  452.         PushAVal(GetWord);
  453.         break;
  454.  
  455.  
  456.                 /* ---Operators--- */
  457.  
  458.                 /* Unary operators */
  459.  
  460.      case Op_Compl:     /* ~e */
  461.      case Op_Neg:        /* -e */
  462.      case Op_Number:    /* +e */
  463.      case Op_Refresh:    /* ^e */
  464.      case Op_Size:        /* *e */
  465.         Setup_Op(1);
  466.         DerefArg(1);
  467.         Call_Cond;
  468.         break;
  469.  
  470.      case Op_Value:     /* .e */
  471.      case Op_Nonnull:    /* \e */
  472.      case Op_Null:        /* /e */
  473.         Setup_Op(1);
  474.         Call_Cond;
  475.         break;
  476.  
  477.      case Op_Random:    /* ?e */
  478.         PushNull;
  479.         Setup_Op(2)
  480.         Call_Cond
  481.         break;
  482.  
  483.                 /* Generative unary operators */
  484.  
  485.      case Op_Tabmat:    /* =e */
  486.         Setup_Op(1);
  487.         DerefArg(1);
  488.         Call_Gen;
  489.  
  490.      case Op_Bang:        /* !e */
  491.         PushNull;
  492.         Setup_Op(2);
  493.         Call_Gen;
  494.  
  495.                 /* Binary operators */
  496.  
  497.      case Op_Cat:        /* e1 || e2 */
  498.      case Op_Diff:        /* e1 -- e2 */
  499.      case Op_Div:        /* e1 / e2 */
  500.      case Op_Inter:     /* e1 ** e2 */
  501.      case Op_Lconcat:    /* e1 ||| e2 */
  502.      case Op_Minus:     /* e1 - e2 */
  503.      case Op_Mod:        /* e1 % e2 */
  504.      case Op_Mult:        /* e1 * e2 */
  505.      case Op_Power:     /* e1 ^ e2 */
  506.      case Op_Unions:    /* e1 ++ e2 */
  507.      case Op_Plus:        /* e1 + e2 */
  508.      case Op_Eqv:        /* e1 === e2 */
  509.      case Op_Lexeq:     /* e1 == e2 */
  510.      case Op_Lexge:     /* e1 >>= e2 */
  511.      case Op_Lexgt:     /* e1 >> e2 */
  512.      case Op_Lexle:     /* e1 <<= e2 */
  513.      case Op_Lexlt:     /* e1 << e2 */
  514.      case Op_Lexne:     /* e1 ~== e2 */
  515.      case Op_Neqv:        /* e1 ~=== e2 */
  516.      case Op_Numeq:     /* e1 = e2 */
  517.      case Op_Numge:     /* e1 >= e2 */
  518.      case Op_Numgt:     /* e1 > e2 */
  519.      case Op_Numle:     /* e1 <= e2 */
  520.      case Op_Numne:     /* e1 ~= e2 */
  521.      case Op_Numlt:     /* e1 < e2 */
  522.         Setup_Op(2);
  523.         DerefArg(1);
  524.         DerefArg(2);
  525.         Call_Cond;
  526.         break;
  527.  
  528.      case Op_Asgn:        /* e1 := e2 */
  529.         Setup_Op(2);
  530.         DerefArg(2);
  531.         Call_Cond;
  532.         break;
  533.  
  534.      case Op_Swap:        /* e1 :=: e2 */
  535.         PushNull;
  536.         Setup_Op(3);
  537.         Call_Cond;
  538.         break;
  539.  
  540.      case Op_Subsc:     /* e1[e2] */
  541.         PushNull;
  542.         Setup_Op(3);
  543.         DerefArg(2);
  544.         Call_Cond;
  545.         break;
  546.                 /* Generative binary operators */
  547.  
  548.      case Op_Rasgn:     /* e1 <- e2 */
  549.         Setup_Op(2);
  550.         DerefArg(2);
  551.         Call_Gen;
  552.  
  553.      case Op_Rswap:     /* e1 <-> e2 */
  554.         PushNull;
  555.         Setup_Op(3);
  556.         Call_Gen;
  557.  
  558.                 /* Conditional ternary operators */
  559.  
  560.      case Op_Sect:        /* e1[e2:e3] */
  561.         PushNull;
  562.         Setup_Op(4);
  563.         DerefArg(2);
  564.         DerefArg(3);
  565.         Call_Cond;
  566.         break;
  567.                 /* Generative ternary operators */
  568.  
  569.      case Op_Toby:        /* e1 to e2 by e3 */
  570.         Setup_Op(3);
  571.         DerefArg(1);
  572.         DerefArg(2);
  573.         DerefArg(3);
  574.         Call_Gen;
  575.  
  576. #ifdef LineCodes
  577.          case Op_Noop:        /* no-op */
  578.  
  579. #ifdef Polling
  580.             pollctr--;
  581.             if (!pollctr)
  582.                pollctr = pollevent();
  583. #endif                    /* Polling */
  584.  
  585.  
  586.             break;
  587.  
  588. #endif                /* LineCodes */
  589.  
  590.  
  591. #ifdef EvalTrace
  592.          case Op_Colm:        /* source column number */
  593.             colmno = GetWord;
  594.             break;
  595.  
  596.          case Op_Line:        /* source line number */
  597.             lineno = GetWord;
  598.             break;
  599. #endif                    /* EvalTrace */
  600.  
  601.                 /* ---String Scanning--- */
  602.  
  603.      case Op_Bscan:     /* prepare for scanning */
  604.         PushDesc(k_subject);
  605.         PushVal(D_Integer);
  606.         PushVal(k_pos);
  607.         Setup_Op(2);
  608.  
  609.         signal = Obscan(2,rargp);
  610.  
  611.         goto C_rtn_term;
  612.  
  613.      case Op_Escan:     /* exit from scanning */
  614.         Setup_Op(1);
  615.  
  616.         signal = Oescan(1,rargp);
  617.  
  618.         goto C_rtn_term;
  619.  
  620.                 /* ---Other Language Operations--- */
  621.  
  622.  
  623.          case Op_Apply: {    /* apply */
  624.             {
  625.             union block *bp;
  626.             int i, j;
  627.  
  628.             list_tmp = *(dptr)(rsp - 1);    /* argument */
  629.             DeRef(list_tmp);
  630.             if (list_tmp.dword != D_List) {    /* be sure it's a list */
  631.                xargp = (dptr)(rsp - 3);
  632.                runerr(108, &list_tmp);
  633.                goto efail;
  634.                } 
  635.             rsp -= 2;                /* pop it off */
  636.             bp = BlkLoc(list_tmp);
  637.             args = (int)bp->list.size;
  638.             for (bp = bp->list.listhead; bp != NULL; bp = bp->lelem.listnext) {
  639.                for (i = 0; i < bp->lelem.nused; i++) {
  640.                   j = bp->lelem.first + i;
  641.                   if (j >= bp->lelem.nslots)
  642.                      j -= bp->lelem.nslots;
  643.                   PushDesc(bp->lelem.lslots[j])
  644.                   }
  645.                }
  646.             goto invokej;
  647.                }
  648.             }
  649.  
  650.      case Op_Invoke: {    /* invoke */
  651.             args = (int)GetWord;
  652. invokej:
  653.         {
  654.             int nargs;
  655.         dptr carg;
  656.  
  657.         ExInterp;
  658.         type = invoke(args, &carg, &nargs);
  659.         rargp = carg;
  660.         EntInterp;
  661.  
  662. #ifdef MaxLevel
  663.         if (k_level > maxplevel)
  664.            maxplevel = k_level;
  665. #endif                    /* MaxLevel */
  666.         if (type == I_Fail)
  667.            goto efail;
  668.         if (type == I_Continue)
  669.            break;
  670.         else {
  671.            int (*bfunc)();
  672.  
  673.            bproc = (struct b_proc *)BlkLoc(*rargp);
  674.            bfunc = bproc->entryp.ccode;
  675.  
  676.            /* ExInterp not needed since no change since last EntInterp */
  677.            if (type == I_Vararg)
  678.  
  679.           signal = (*bfunc)(nargs,rargp);
  680.  
  681.            else
  682.  
  683.           signal = (*bfunc)(rargp);
  684.  
  685.  
  686.            goto C_rtn_term;
  687.            }
  688.         }
  689.         break;
  690.         }
  691.  
  692.      case Op_Keywd:     /* keyword */
  693.         PushVal(D_Integer);
  694.         PushVal(GetWord);
  695.         Setup_Op(0);
  696.  
  697.         signal = Okeywd(0,rargp);
  698.         goto C_rtn_term;
  699.  
  700.      case Op_Llist:     /* construct list */
  701.         opnd = GetWord;
  702.         Setup_Op(opnd);
  703.  
  704.         signal = Ollist((int)opnd,rargp);
  705.         goto C_rtn_term;
  706.  
  707.                 /* ---Marking and Unmarking--- */
  708.  
  709.      case Op_Mark:        /* create expression frame marker */
  710.         PutOp(Op_Amark);
  711.         opnd = GetWord;
  712.         opnd += (word)ipc.opnd;
  713.         PutWord(opnd);
  714.         newefp = (struct ef_marker *)(rsp + 1);
  715.         newefp->ef_failure.opnd = (word *)opnd;
  716.         goto mark;
  717.  
  718.      case Op_Amark:     /* mark with absolute fipc */
  719.         newefp = (struct ef_marker *)(rsp + 1);
  720.         newefp->ef_failure.opnd = (word *)GetWord;
  721. mark:
  722.         newefp->ef_gfp = gfp;
  723.         newefp->ef_efp = efp;
  724.         newefp->ef_ilevel = ilevel;
  725.         rsp += Wsizeof(*efp);
  726.         efp = newefp;
  727.         gfp = 0;
  728.         break;
  729.  
  730.      case Op_Mark0:     /* create expression frame with 0 ipl */
  731. mark0:
  732.         newefp = (struct ef_marker *)(rsp + 1);
  733.         newefp->ef_failure.opnd = 0;
  734.         newefp->ef_gfp = gfp;
  735.         newefp->ef_efp = efp;
  736.         newefp->ef_ilevel = ilevel;
  737.         rsp += Wsizeof(*efp);
  738.         efp = newefp;
  739.         gfp = 0;
  740.         break;
  741.  
  742.      case Op_Unmark:    /* remove expression frame */
  743.         gfp = efp->ef_gfp;
  744.         rsp = (word *)efp - 1;
  745.  
  746.         /*
  747.          * Remove any suspended C generators.
  748.          */
  749. Unmark_uw:
  750.         if (efp->ef_ilevel < ilevel) {
  751.            --ilevel;
  752.            ExInterp;
  753.            return A_Unmark_uw;
  754.            }
  755.         efp = efp->ef_efp;
  756.         break;
  757.  
  758.                 /* ---Suspensions--- */
  759.  
  760.      case Op_Esusp: {    /* suspend from expression */
  761.  
  762.         /*
  763.          * Create the generator frame.
  764.          */
  765.         oldsp = rsp;
  766.         newgfp = (struct gf_marker *)(rsp + 1);
  767.         newgfp->gf_gentype = G_Esusp;
  768.         newgfp->gf_gfp = gfp;
  769.         newgfp->gf_efp = efp;
  770.         newgfp->gf_ipc = ipc;
  771.         gfp = newgfp;
  772.         rsp += Wsizeof(struct gf_smallmarker);
  773.  
  774.         /*
  775.          * Region extends from first word after enclosing generator or
  776.          *    expression frame marker to marker for current expression frame.
  777.          */
  778.         if (efp->ef_gfp != 0) {
  779.            newgfp = (struct gf_marker *)(efp->ef_gfp);
  780.            if (newgfp->gf_gentype == G_Psusp)
  781.           firstwd = (word *)efp->ef_gfp + Wsizeof(*gfp);
  782.            else
  783.           firstwd = (word *)efp->ef_gfp +
  784.              Wsizeof(struct gf_smallmarker);
  785.         }
  786.         else
  787.            firstwd = (word *)efp->ef_efp + Wsizeof(*efp);
  788.         lastwd = (word *)efp - 1;
  789.         efp = efp->ef_efp;
  790.  
  791.         /*
  792.          * Copy the portion of the stack with endpoints firstwd and lastwd
  793.          *    (inclusive) to the top of the stack.
  794.          */
  795.         for (wd = firstwd; wd <= lastwd; wd++)
  796.            *++rsp = *wd;
  797.         PushVal(oldsp[-1]);
  798.         PushVal(oldsp[0]);
  799.         break;
  800.         }
  801.  
  802.      case Op_Lsusp: {    /* suspend from limitation */
  803.         struct descrip sval;
  804.  
  805.         /*
  806.          * The limit counter is contained in the descriptor immediately
  807.          *    prior to the current expression frame.    lval is established
  808.          *    as a pointer to this descriptor.
  809.          */
  810.         dptr lval = (dptr)((word *)efp - 2);
  811.  
  812.         /*
  813.          * Decrement the limit counter and check it.
  814.          */
  815.         if (--IntVal(*lval) > 0) {
  816.            /*
  817.         * The limit has not been reached, set up stack.
  818.         */
  819.  
  820.            sval = *(dptr)(rsp - 1);    /* save result */
  821.  
  822.            /*
  823.         * Region extends from first word after enclosing generator or
  824.         *  expression frame marker to the limit counter just prior to
  825.         *  to the current expression frame marker.
  826.         */
  827.            if (efp->ef_gfp != 0) {
  828.           newgfp = (struct gf_marker *)(efp->ef_gfp);
  829.           if (newgfp->gf_gentype == G_Psusp)
  830.              firstwd = (word *)efp->ef_gfp + Wsizeof(*gfp);
  831.           else
  832.              firstwd = (word *)efp->ef_gfp +
  833.             Wsizeof(struct gf_smallmarker);
  834.           }
  835.            else
  836.           firstwd = (word *)efp->ef_efp + Wsizeof(*efp);
  837.            lastwd = (word *)efp - 3;
  838.            if (gfp == 0)
  839.           gfp = efp->ef_gfp;
  840.            efp = efp->ef_efp;
  841.  
  842.            /*
  843.         * Copy the portion of the stack with endpoints firstwd and lastwd
  844.         *  (inclusive) to the top of the stack.
  845.         */
  846.            rsp -= 2;        /* overwrite result */
  847.            for (wd = firstwd; wd <= lastwd; wd++)
  848.           *++rsp = *wd;
  849.            PushDesc(sval);        /* push saved result */
  850.            }
  851.         else {
  852.            /*
  853.         * Otherwise, the limit has been reached.  Instead of
  854.         *  suspending, remove the current expression frame and
  855.         *  replace the limit counter with the value on top of
  856.         *  the stack (which would have been suspended had the
  857.         *  limit not been reached).
  858.         */
  859.            *lval = *(dptr)(rsp - 1);
  860.            gfp = efp->ef_gfp;
  861.  
  862.            /*
  863.         * Since an expression frame is being removed, inactive
  864.         *  C generators contained therein are deactivated.
  865.         */
  866. Lsusp_uw:
  867.            if (efp->ef_ilevel < ilevel) {
  868.           --ilevel;
  869.           ExInterp;
  870.           return A_Lsusp_uw;
  871.           }
  872.            rsp = (word *)efp - 1;
  873.            efp = efp->ef_efp;
  874.            }
  875.         break;
  876.         }
  877.  
  878.      case Op_Psusp: {    /* suspend from procedure */
  879.         /*
  880.          * An Icon procedure is suspending a value.  Determine if the
  881.          *    value being suspended should be dereferenced and if so,
  882.          *    dereference it. If tracing is on, strace is called
  883.          *  to generate a message.  Appropriate values are
  884.          *    restored from the procedure frame of the suspending procedure.
  885.          */
  886.  
  887.         struct descrip tmp;
  888.         struct descrip sval, *svalp;
  889.         struct b_proc *sproc;
  890.  
  891.         svalp = (dptr)(rsp - 1);
  892.         sval = *svalp;
  893.         if (Var(sval)) {
  894.            word *loc;
  895.  
  896.            if (Tvar(sval)) {
  897.           if (sval.dword == D_Tvsubs) {
  898.               struct b_tvsubs *tvb;
  899.  
  900.              tvb = (struct b_tvsubs *)BlkLoc(sval);
  901.              loc = (word *)BlkLoc(tvb->ssvar);
  902.              if (!Tvar(tvb->ssvar))
  903.             loc += Offset(tvb->ssvar);
  904.              }
  905.           else
  906.              goto ps_noderef;
  907.             }
  908.            else
  909.           loc = (word *)VarLoc(sval) + Offset(sval);
  910.                   if (InRange(BlkLoc(k_current),loc,rsp))
  911.              if (DeRef(*svalp) == Error) {
  912.                 runerr(0, NULL);
  913.                 goto efail;
  914.                 }
  915.            }
  916. ps_noderef:
  917.  
  918.         /*
  919.          * Create the generator frame.
  920.          */
  921.         oldsp = rsp;
  922.         newgfp = (struct gf_marker *)(rsp + 1);
  923.         newgfp->gf_gentype = G_Psusp;
  924.         newgfp->gf_gfp = gfp;
  925.         newgfp->gf_efp = efp;
  926.         newgfp->gf_ipc = ipc;
  927.         newgfp->gf_argp = argp;
  928.         newgfp->gf_pfp = pfp;
  929.         gfp = newgfp;
  930.         rsp += Wsizeof(*gfp);
  931.  
  932.         /*
  933.          * Region extends from first word after the marker for the
  934.          *    generator or expression frame enclosing the call to the
  935.          *    now-suspending procedure to Arg0 of the procedure.
  936.          */
  937.         if (pfp->pf_gfp != 0) {
  938.            newgfp = (struct gf_marker *)(pfp->pf_gfp);
  939.            if (newgfp->gf_gentype == G_Psusp)
  940.           firstwd = (word *)pfp->pf_gfp + Wsizeof(*gfp);
  941.            else
  942.           firstwd = (word *)pfp->pf_gfp +
  943.              Wsizeof(struct gf_smallmarker);
  944.            }
  945.         else
  946.            firstwd = (word *)pfp->pf_efp + Wsizeof(*efp);
  947.         lastwd = (word *)argp - 1;
  948.            efp = efp->ef_efp;
  949.  
  950.         /*
  951.          * Copy the portion of the stack with endpoints firstwd and lastwd
  952.          *    (inclusive) to the top of the stack.
  953.          */
  954.         for (wd = firstwd; wd <= lastwd; wd++)
  955.            *++rsp = *wd;
  956.         PushVal(oldsp[-1]);
  957.         PushVal(oldsp[0]);
  958.         --k_level;
  959.         if (k_trace) {
  960.                k_trace--;
  961.            sproc = (struct b_proc *)BlkLoc(*argp);
  962.            strace(&(sproc->pname), svalp);
  963.            }
  964.  
  965.         /*
  966.          * If the scanning environment for this procedure call is in
  967.          *    a saved state, switch environments.
  968.          */
  969.         if (pfp->pf_scan != NULL) {
  970.            tmp = k_subject;
  971.            k_subject = *pfp->pf_scan;
  972.            *pfp->pf_scan = tmp;
  973.  
  974.            tmp = *(pfp->pf_scan + 1);
  975.            IntVal(*(pfp->pf_scan + 1)) = k_pos;
  976.            k_pos = IntVal(tmp);
  977.            }
  978.         efp = pfp->pf_efp;
  979.         ipc = pfp->pf_ipc;
  980.         argp = pfp->pf_argp;
  981.         pfp = pfp->pf_pfp;
  982.         break;
  983.         }
  984.  
  985.                 /* ---Returns--- */
  986.  
  987.      case Op_Eret: {    /* return from expression */
  988.         /*
  989.          * Op_Eret removes the current expression frame, leaving the
  990.          *    original top of stack value on top.
  991.          */
  992.         /*
  993.          * Save current top of stack value in global temporary (no
  994.          *    danger of reentry).
  995.          */
  996.         eret_tmp = *(dptr)&rsp[-1];
  997.         gfp = efp->ef_gfp;
  998. Eret_uw:
  999.         /*
  1000.          * Since an expression frame is being removed, inactive
  1001.          *    C generators contained therein are deactivated.
  1002.          */
  1003.         if (efp->ef_ilevel < ilevel) {
  1004.            --ilevel;
  1005.            ExInterp;
  1006.            return A_Eret_uw;
  1007.            }
  1008.         rsp = (word *)efp - 1;
  1009.         efp = efp->ef_efp;
  1010.         PushDesc(eret_tmp);
  1011.         break;
  1012.         }
  1013.  
  1014.      case Op_Pret: {    /* return from procedure */
  1015.         /*
  1016.          * An Icon procedure is returning a value.    Determine if the
  1017.          *    value being returned should be dereferenced and if so,
  1018.          *    dereference it.  If tracing is on, rtrace is called to
  1019.          *    generate a message.  Inactive generators created after
  1020.          *    the activation of the procedure are deactivated.  Appropriate
  1021.          *    values are restored from the procedure frame.
  1022.          */
  1023.         struct descrip rval;
  1024.         struct b_proc *rproc = (struct b_proc *)BlkLoc(*argp);
  1025.  
  1026.         *argp = *(dptr)(rsp - 1);
  1027.         rval = *argp;
  1028.         if (Var(rval)) {
  1029.            word *loc;
  1030.  
  1031.            if (Tvar(rval)) {
  1032.           if (rval.dword == D_Tvsubs) {
  1033.               struct b_tvsubs *tvb;
  1034.  
  1035.              tvb = (struct b_tvsubs *)BlkLoc(rval);
  1036.              loc = (word *)BlkLoc(tvb->ssvar);
  1037.              if (!Tvar(tvb->ssvar))
  1038.             loc += Offset(tvb->ssvar);
  1039.              }
  1040.           else
  1041.              goto pr_noderef;
  1042.           }
  1043.            else
  1044.           loc = (word *)VarLoc(rval) + Offset(rval);
  1045.                if (InRange(BlkLoc(k_current),loc,rsp))
  1046.           if (DeRef(*argp) == Error) {
  1047.              runerr(0, NULL);
  1048.              goto efail;
  1049.              }
  1050.            }
  1051.  
  1052. pr_noderef:
  1053.         --k_level;
  1054.         if (k_trace) {
  1055.                k_trace--;
  1056.            rtrace(&(rproc->pname), argp);
  1057.                }
  1058. Pret_uw:
  1059.         if (pfp->pf_ilevel < ilevel) {
  1060.            --ilevel;
  1061.            ExInterp;
  1062.            return A_Pret_uw;
  1063.            }
  1064.         rsp = (word *)argp + 1;
  1065.         efp = pfp->pf_efp;
  1066.         gfp = pfp->pf_gfp;
  1067.         ipc = pfp->pf_ipc;
  1068.         argp = pfp->pf_argp;
  1069.         pfp = pfp->pf_pfp;
  1070.         break;
  1071.         }
  1072.  
  1073.                 /* ---Failures--- */
  1074.  
  1075.      case Op_Efail:
  1076. efail:
  1077.         /*
  1078.          * Failure has occurred in the current expression frame.
  1079.          */
  1080.         if (gfp == 0) {
  1081.            /*
  1082.         * There are no suspended generators to resume.
  1083.         *  Remove the current expression frame, restoring
  1084.         *  values.
  1085.         *
  1086.         * If the failure ipc is 0, propagate failure to the
  1087.         *  enclosing frame by branching back to efail.
  1088.         *  This happens, for example, in looping control
  1089.         *  structures that fail when complete.
  1090.         */
  1091.            ipc = efp->ef_failure;
  1092.            gfp = efp->ef_gfp;
  1093.            rsp = (word *)efp - 1;
  1094.            efp = efp->ef_efp;
  1095.            if (ipc.op == 0)
  1096.           goto efail;
  1097.            break;
  1098.            }
  1099.  
  1100.         else {
  1101.            /*
  1102.         * There is a generator that can be resumed.  Make
  1103.         *  the stack adjustments and then switch on the
  1104.         *  type of the generator frame marker.
  1105.         */
  1106.            struct descrip tmp;
  1107.            register struct gf_marker *resgfp = gfp;
  1108.  
  1109.            type = (int)resgfp->gf_gentype;
  1110.  
  1111.  
  1112.            if (type == G_Psusp) {
  1113.           argp = resgfp->gf_argp;
  1114.           if (k_trace) {    /* procedure tracing */
  1115.                      k_trace--;
  1116.              ExInterp;
  1117.              atrace(&(((struct b_proc *)BlkLoc(*argp))->pname));
  1118.              EntInterp;
  1119.              }
  1120.           }
  1121.            ipc = resgfp->gf_ipc;
  1122.            efp = resgfp->gf_efp;
  1123.            gfp = resgfp->gf_gfp;
  1124.            rsp = (word *)resgfp - 1;
  1125.            if (type == G_Psusp) {
  1126.           pfp = resgfp->gf_pfp;
  1127.  
  1128.           /*
  1129.            * If the scanning environment for this procedure call is
  1130.            *  supposed to be in a saved state, switch environments.
  1131.            */
  1132.           if (pfp->pf_scan != NULL) {
  1133.              tmp = k_subject;
  1134.              k_subject = *pfp->pf_scan;
  1135.              *pfp->pf_scan = tmp;
  1136.  
  1137.              tmp = *(pfp->pf_scan + 1);
  1138.              IntVal(*(pfp->pf_scan + 1)) = k_pos;
  1139.              k_pos = IntVal(tmp);
  1140.              }
  1141.           ++k_level;        /* adjust procedure level */
  1142.           }
  1143.  
  1144.            switch (type) {
  1145.  
  1146.           case G_Csusp: {
  1147.              --ilevel;
  1148.              ExInterp;
  1149.              return A_Resumption;
  1150.              break;
  1151.              }
  1152.  
  1153.           case G_Esusp:
  1154.              goto efail;
  1155.  
  1156.           case G_Psusp:
  1157.              break;
  1158.           }
  1159.  
  1160.            break;
  1161.            }
  1162.  
  1163.      case Op_Pfail:     /* fail from procedure */
  1164.         /*
  1165.          * An Icon procedure is failing.  Generate tracing message if
  1166.          *    tracing is on.    Deactivate inactive C generators created
  1167.          *    after activation of the procedure.  Appropriate values
  1168.          *    are restored from the procedure frame.
  1169.          */
  1170.         --k_level;
  1171.         if (k_trace) {
  1172.                k_trace--;
  1173.            failtrace(&(((struct b_proc *)BlkLoc(*argp))->pname));
  1174.                }
  1175. Pfail_uw:
  1176.         if (pfp->pf_ilevel < ilevel) {
  1177.            --ilevel;
  1178.            ExInterp;
  1179.            return A_Pfail_uw;
  1180.            }
  1181.         efp = pfp->pf_efp;
  1182.         gfp = pfp->pf_gfp;
  1183.         ipc = pfp->pf_ipc;
  1184.         argp = pfp->pf_argp;
  1185.         pfp = pfp->pf_pfp;
  1186.         goto efail;
  1187.  
  1188.                 /* ---Odds and Ends--- */
  1189.  
  1190.      case Op_Ccase:     /* case clause */
  1191.         PushNull;
  1192.         PushVal(((word *)efp)[-2]);
  1193.         PushVal(((word *)efp)[-1]);
  1194.         break;
  1195.  
  1196.      case Op_Chfail:    /* change failure ipc */
  1197.         opnd = GetWord;
  1198.         opnd += (word)ipc.opnd;
  1199.         efp->ef_failure.opnd = (word *)opnd;
  1200.         break;
  1201.  
  1202.      case Op_Dup:        /* duplicate descriptor */
  1203.         PushNull;
  1204.         rsp[1] = rsp[-3];
  1205.         rsp[2] = rsp[-2];
  1206.         rsp += 2;
  1207.         break;
  1208.  
  1209.      case Op_Field:     /* e1.e2 */
  1210.         PushVal(D_Integer);
  1211.         PushVal(GetWord);
  1212.         Setup_Op(2);
  1213.  
  1214.         signal = Ofield(2,rargp);
  1215.  
  1216.         goto C_rtn_term;
  1217.  
  1218.      case Op_Goto:        /* goto */
  1219.         PutOp(Op_Agoto);
  1220.         opnd = GetWord;
  1221.         opnd += (word)ipc.opnd;
  1222.         PutWord(opnd);
  1223.         ipc.opnd = (word *)opnd;
  1224.         break;
  1225.  
  1226.      case Op_Agoto:     /* goto absolute address */
  1227.         opnd = GetWord;
  1228.         ipc.opnd = (word *)opnd;
  1229.         break;
  1230.  
  1231.      case Op_Init:        /* initial */
  1232.  
  1233. #ifdef WATERLOO_C_V3_0
  1234.            cw3defect = ipc.op;
  1235.            cw3defect--;
  1236.            ipc.op = cw3defect;
  1237.            *cw3defect = Op_Goto;
  1238. #else                    /* WATERLOO_C_V3_0 */
  1239.         *--ipc.op = Op_Goto;
  1240. #endif                    /* WATERLOO_C_V3_0 */
  1241.  
  1242.         opnd = sizeof(*ipc.op) + sizeof(*rsp);
  1243.         opnd += (word)ipc.opnd;
  1244.         ipc.opnd = (word *)opnd;
  1245.         break;
  1246.  
  1247.      case Op_Limit:     /* limit */
  1248.         Setup_Op(0);
  1249.  
  1250.         if (Olimit(0,rargp) == A_Failure)
  1251.  
  1252.            goto efail;
  1253.         else
  1254.            rsp = (word *) rargp + 1;
  1255.         goto mark0;
  1256.  
  1257. #ifdef TallyOpt
  1258.      case Op_Tally:     /* tally */
  1259.         tallybin[GetWord]++;
  1260.         break;
  1261. #endif                    /* TallyOpt */
  1262.  
  1263.      case Op_Pnull:     /* push null descriptor */
  1264.         PushNull;
  1265.         break;
  1266.  
  1267.      case Op_Pop:        /* pop descriptor */
  1268.         rsp -= 2;
  1269.         break;
  1270.  
  1271.      case Op_Push1:     /* push integer 1 */
  1272.         PushVal(D_Integer);
  1273.         PushVal(1);
  1274.         break;
  1275.  
  1276.      case Op_Pushn1:    /* push integer -1 */
  1277.         PushVal(D_Integer);
  1278.         PushVal(-1);
  1279.         break;
  1280.  
  1281.      case Op_Sdup:        /* duplicate descriptor */
  1282.         rsp += 2;
  1283.         rsp[-1] = rsp[-3];
  1284.         rsp[0] = rsp[-2];
  1285.         break;
  1286.  
  1287.                     /* ---Co-expressions--- */
  1288.  
  1289.      case Op_Create:    /* create */
  1290.  
  1291. #ifdef Coexpr
  1292.         PushNull;
  1293.         Setup_Op(0);
  1294.         opnd = GetWord;
  1295.         opnd += (word)ipc.opnd;
  1296.  
  1297.         signal = Ocreate((word *)opnd, rargp);
  1298.  
  1299.         goto C_rtn_term;
  1300. #else                    /* Coexpr */
  1301.         runerr(-401, NULL);
  1302.         goto efail;
  1303. #endif                    /* Coexpr */
  1304.  
  1305.      case Op_Coact: {    /* @e */
  1306.  
  1307. #ifndef Coexpr
  1308.         runerr(-401, NULL);
  1309.         goto efail;
  1310. #else                    /* Coexpr */
  1311.  
  1312.         register struct b_coexpr *ccp, *ncp;
  1313.         dptr dp, tvalp;
  1314.             struct descrip tval;
  1315.         int first;
  1316.  
  1317.         ExInterp;
  1318.         dp = (dptr)(sp - 1);
  1319.  
  1320. #ifdef TraceBack
  1321.         xargp = dp - 2;
  1322. #endif                        /* TraceBack */
  1323.  
  1324.         if (DeRef(*dp) == Error) {
  1325.            runerr(0, NULL);
  1326.            goto efail;
  1327.            }
  1328.         if (dp->dword != D_Coexpr) {
  1329.         runerr(118, dp);
  1330.         goto efail;
  1331.         }
  1332.         ccp = (struct b_coexpr *)BlkLoc(k_current);
  1333.         ncp = (struct b_coexpr *)BlkLoc(*dp);
  1334.  
  1335.         /*
  1336.          * Dereference the transmited value if needed.
  1337.          */
  1338.         tval = *(dptr)(sp - 3);
  1339.         if (Var(tval)) {
  1340.            word *loc;
  1341.  
  1342.  
  1343.            if (Tvar(tval)) {
  1344.           if (tval.dword == D_Tvsubs) {
  1345.             struct b_tvsubs *tvb;
  1346.  
  1347.                      tvb = (struct b_tvsubs *)BlkLoc(tval);
  1348.                      loc = (word *)BlkLoc(tvb->ssvar);
  1349.                      if (!Tvar(tvb->ssvar))
  1350.                         loc += Offset(tvb->ssvar);
  1351.             }
  1352.           else
  1353.             goto ca_noderef;
  1354.           }
  1355.            else
  1356.           loc = (word *)VarLoc(tval) + Offset(tval);
  1357.                if (InRange(ccp,loc,sp))
  1358.           if (DeRef(tval) == Error) {
  1359.              runerr(0, NULL);
  1360.              goto efail;
  1361.              }
  1362.            }
  1363. ca_noderef:
  1364.         /*
  1365.          * Set activator in new co-expression.
  1366.          */
  1367.         if (ncp->es_actstk == NULL) {
  1368.            ncp->es_actstk = alcactiv();
  1369.            if (ncp->es_actstk == NULL) {
  1370.              runerr(0, NULL);
  1371.              goto efail;
  1372.              }
  1373.            first = 0;
  1374.            }
  1375.         else
  1376.            first = 1;
  1377.         if (pushact(ncp, ccp) == Error) {
  1378.            runerr(0, NULL);
  1379.            goto efail;
  1380.            }
  1381.  
  1382.         if (k_trace) {
  1383.                k_trace--;
  1384.            coacttrace(ccp, ncp);
  1385.                }
  1386.         /*
  1387.          * Save Istate of current co-expression.
  1388.          */
  1389.         ccp->es_pfp = pfp;
  1390.         ccp->es_argp = argp;
  1391.         ccp->es_efp = efp;
  1392.         ccp->es_gfp = gfp;
  1393.         ccp->es_ipc = ipc;
  1394.         ccp->es_sp = sp;
  1395.         ccp->es_ilevel = ilevel;
  1396.         ccp->tvalloc = (dptr)(sp - 3);
  1397.         /*
  1398.          * Establish Istate for new co-expression.
  1399.          */
  1400.         pfp = ncp->es_pfp;
  1401.         argp = ncp->es_argp;
  1402.         efp = ncp->es_efp;
  1403.         gfp = ncp->es_gfp;
  1404.         ipc = ncp->es_ipc;
  1405.         sp = ncp->es_sp;
  1406.         ilevel = (int)ncp->es_ilevel;
  1407.  
  1408.         if (tvalp = ncp->tvalloc) {
  1409.         ncp->tvalloc = NULL;
  1410.         *tvalp = tval;
  1411.         }
  1412.         BlkLoc(k_current) = (union block *)ncp;
  1413.         coexp_act = A_Coact;
  1414.         coswitch(ccp->cstate,ncp->cstate,first);
  1415.         EntInterp;
  1416.         if (coexp_act == A_Cofail)
  1417.         goto efail;
  1418.         else
  1419.         rsp -= 2;
  1420.         break;
  1421. #endif                    /* Coexpr */
  1422.         }
  1423.  
  1424.      case Op_Coret: {    /* return from co-expression */
  1425.  
  1426. #ifndef Coexpr
  1427.         runerr(-401, NULL);     /* can't happen? */
  1428.         goto efail;
  1429. #else                    /* Coexpr */
  1430.         register struct b_coexpr *ccp, *ncp;
  1431.         struct descrip rval, *rvalp;
  1432.  
  1433.         ExInterp;
  1434.         ccp = (struct b_coexpr *)BlkLoc(k_current);
  1435.  
  1436.         /*
  1437.          * Dereference the returned value if needed.
  1438.          */
  1439.         rval = *(dptr)&sp[-1];
  1440.         if (Var(rval)) {
  1441.            word *loc;
  1442.  
  1443.            if (Tvar(rval)) {
  1444.           if (rval.dword == D_Tvsubs) {
  1445.               struct b_tvsubs *tvb;
  1446.  
  1447.              tvb = (struct b_tvsubs *)BlkLoc(rval);
  1448.              loc = (word *)BlkLoc(tvb->ssvar);
  1449.              if (!Tvar(tvb->ssvar))
  1450.             loc += Offset(tvb->ssvar);
  1451.              }
  1452.           else
  1453.              goto cr_noderef;
  1454.           }
  1455.            else
  1456.           loc = (word *)VarLoc(rval) + Offset(rval);
  1457.                if (InRange(ccp,loc,sp))
  1458.           if (DeRef(rval) == Error) {
  1459.              runerr(0, NULL);
  1460.              goto efail;
  1461.              }
  1462.            }
  1463.  
  1464. cr_noderef:
  1465.         ccp->size++;
  1466.         ncp = popact(ccp);
  1467.         ncp->tvalloc = NULL;
  1468.         rvalp = (dptr)(&ncp->es_sp[-3]);
  1469.         *rvalp = rval;
  1470.         if (k_trace) {
  1471.                k_trace--;
  1472.            corettrace(ccp,ncp);
  1473.                }
  1474.  
  1475.         /*
  1476.          * Save Istate of current co-expression.
  1477.          */
  1478.         ccp->es_pfp = pfp;
  1479.         ccp->es_argp = argp;
  1480.         ccp->es_efp = efp;
  1481.         ccp->es_gfp = gfp;
  1482.         ccp->es_ipc = ipc;
  1483.         ccp->es_sp = sp;
  1484.         ccp->es_ilevel = ilevel;
  1485.         /*
  1486.          * Establish Istate for new co-expression.
  1487.          */
  1488.         pfp = ncp->es_pfp;
  1489.         argp = ncp->es_argp;
  1490.         efp = ncp->es_efp;
  1491.         gfp = ncp->es_gfp;
  1492.         ipc = ncp->es_ipc;
  1493.         sp = ncp->es_sp;
  1494.         ilevel = (int)ncp->es_ilevel;
  1495.         BlkLoc(k_current) = (union block *)ncp;
  1496.         coexp_act = A_Coret;
  1497.         coswitch(ccp->cstate, ncp->cstate,1);
  1498.         break;
  1499. #endif                    /* Coexpr */
  1500.         }
  1501.  
  1502.      case Op_Cofail: {    /* fail from co-expression */
  1503.  
  1504. #ifndef Coexpr
  1505.         runerr(-401, NULL);     /* can't happen? */
  1506.         goto efail;
  1507. #else                    /* Coexpr */
  1508.         register struct b_coexpr *ccp, *ncp;
  1509.  
  1510.         ExInterp;
  1511.         ccp = (struct b_coexpr *)BlkLoc(k_current);
  1512.         ncp = popact(ccp);
  1513.         if (k_trace) {
  1514.                k_trace--;
  1515.            cofailtrace(ccp, ncp);
  1516.                }
  1517.         ncp->tvalloc = NULL;
  1518.         /*
  1519.          * Save Istate of current co-expression.
  1520.          */
  1521.         ccp->es_pfp = pfp;
  1522.         ccp->es_argp = argp;
  1523.         ccp->es_efp = efp;
  1524.         ccp->es_gfp = gfp;
  1525.         ccp->es_ipc = ipc;
  1526.         ccp->es_sp = sp;
  1527.         ccp->es_ilevel = ilevel;
  1528.         /*
  1529.          * Establish Istate for new co-expression.
  1530.          */
  1531.         pfp = ncp->es_pfp;
  1532.         argp = ncp->es_argp;
  1533.         efp = ncp->es_efp;
  1534.         gfp = ncp->es_gfp;
  1535.         ipc = ncp->es_ipc;
  1536.         sp = ncp->es_sp;
  1537.         ilevel = (int)ncp->es_ilevel;
  1538.         BlkLoc(k_current) = (union block *)ncp;
  1539.         coexp_act = A_Cofail;
  1540.         coswitch(ccp->cstate, ncp->cstate,1);
  1541.         EntInterp;
  1542.         break;
  1543. #endif                    /* Coexpr */
  1544.  
  1545.         }
  1546.  
  1547.          case Op_Quit:        /* quit */
  1548.  
  1549. #ifdef IconCalling
  1550.             ExInterp;        /* restores stack pointer for icon_call */
  1551.         interp_status = A_Pret_uw;
  1552. #endif                     /* IconCalling */
  1553.  
  1554.         goto interp_quit;
  1555.  
  1556. #ifdef IconCalling
  1557.          case Op_FQuit:        /* failing quit */
  1558.         ExInterp;        /* restores stack pointer for icon_call */
  1559.         interp_status = A_Pfail_uw;
  1560.             goto interp_quit;
  1561. #endif                     /* IconCalling */
  1562.  
  1563.      default: {
  1564.         char buf[50];
  1565.  
  1566.         sprintf(buf, "unimplemented opcode: %ld (0x%08x)\n",
  1567.                (long)lastop, lastop);
  1568.         syserr(buf);
  1569.         }
  1570.      }
  1571.      continue;
  1572.  
  1573. C_rtn_term:
  1574.      EntInterp;
  1575.      switch (signal) {
  1576.  
  1577.         case A_Failure:
  1578.            goto efail;
  1579.  
  1580.         case A_Unmark_uw:        /* unwind for unmark */
  1581.            goto Unmark_uw;
  1582.  
  1583.         case A_Lsusp_uw:        /* unwind for lsusp */
  1584.            goto Lsusp_uw;
  1585.  
  1586.         case A_Eret_uw:        /* unwind for eret */
  1587.            goto Eret_uw;
  1588.  
  1589.         case A_Pret_uw:        /* unwind for pret */
  1590.            goto Pret_uw;
  1591.  
  1592.         case A_Pfail_uw:        /* unwind for pfail */
  1593.            goto Pfail_uw;
  1594.         }
  1595.  
  1596.      rsp = (word *)rargp + 1;    /* set rsp to result */
  1597.      continue;
  1598.      }
  1599.  
  1600. interp_quit:
  1601.    --ilevel;
  1602. #ifdef MaxLevel
  1603.    fprintf(stderr,"maximum &level = %d\n",maxplevel);
  1604.    fprintf(stderr,"maximum ilevel = %d\n",maxilevel);
  1605.    fprintf(stderr,"maximum sp = %d\n",(long)maxsp - (long)stack);
  1606.    fflush(stderr);
  1607. #endif                    /* MaxLevel */
  1608.  
  1609. #ifdef DumpIcount
  1610.    {
  1611.    int i;
  1612.    for (i = 0; i <= MaxIcode; i++)
  1613.       fprintf(imonc,"\%d\n",icode[i]);
  1614.       fflush(imonc);
  1615.    }
  1616. #endif                    /* DumpIcount */
  1617.  
  1618. #ifndef IconCalling
  1619.    if (ilevel != 0)
  1620.       syserr("interp: termination with inactive generators.");
  1621. #else
  1622.    if (IDepth == 0 && ilevel != 0)
  1623.       syserr("interp(call in): termination with inactive generators");
  1624. #endif                    /* IconCalling */
  1625.  
  1626.  
  1627.    }
  1628.  
  1629. #ifdef StackPic
  1630. /*
  1631.  * The following code is operating-system dependent [@interp.04].
  1632.  *  Diagnostic stack pictures for debugging/monitoring.
  1633.  */
  1634.  
  1635. #if PORT
  1636. Deliberate Syntax Error
  1637. #endif                    /* PORT */
  1638.  
  1639. #if AMIGA || ATARI_ST || HIGHC_386 || MACINTOSH || MVS || VM || VMS
  1640.    /* not included */
  1641. #endif                    /* AMIGA || ATARI_ST || ... */
  1642.  
  1643. #if MSDOS || OS2
  1644. novalue stkdump(op)
  1645.    int op;
  1646.    {
  1647.    word far *stk;
  1648.    word far *i;
  1649.    stk = (word far *)BlkLoc(k_current);
  1650.    stk += Wsizeof(struct b_coexpr);
  1651.    fprintf(stderr,">  stack:  %08lx\n", (word)stk);
  1652.    fprintf(stderr,">  sp:     %08lx\n", (word)sp);
  1653.    fprintf(stderr,">  pfp:    %08lx\n", (word)pfp);
  1654.    fprintf(stderr,">  efp:    %08lx\n", (word)efp);
  1655.    fprintf(stderr,">  gfp:    %08lx\n", (word)gfp);
  1656.    fprintf(stderr,">  ipc:    %08lx\n", (word)ipc.op);
  1657.    fprintf(stderr,">  argp:   %08lx\n", (word)argp);
  1658.    fprintf(stderr,">  ilevel: %08lx\n", (word)ilevel);
  1659.    fprintf(stderr,">  op:     %d\n",    (int)op);
  1660.    for (i = stk; i <= (word far *)sp; i++)
  1661.       fprintf(stderr,"> %08lx\n",(word)*i);
  1662.    fprintf(stderr,"> ----------\n");
  1663.    fflush(stderr);
  1664.    }
  1665. #endif                    /* MSDOS || OS2 */
  1666.  
  1667. #if UNIX || VMS
  1668. novalue stkdump(op)
  1669.    int op;
  1670.    {
  1671.    long *i;
  1672.    fprintf(stderr,"\001stack: %lx\n",(long)(stack + Wsizeof(struct b_coexpr)));
  1673.    fprintf(stderr,"\001pfp: %lx\n",(long)pfp);
  1674.    fprintf(stderr,"\001efp: %lx\n",(long)efp);
  1675.    fprintf(stderr,"\001gfp: %lx\n",(long)gfp);
  1676.    fprintf(stderr,"\001ipc: %lx\n",(long)ipc.op);
  1677.    fprintf(stderr,"\001argp: %lx\n",(long)argp);
  1678.    fprintf(stderr,"\001ilevel: %lx\n",(long)ilevel);
  1679.    fprintf(stderr,"\001op: \%d\n",(int)op);
  1680.    for (i = stack + Wsizeof(struct b_coexpr); i <= sp; i++)
  1681.       fprintf(stderr,"\001%lx\n",*i);
  1682.    fprintf(stderr,"\001----------\n");
  1683.    fflush(stderr);
  1684.    }
  1685. #endif                    /* UNIX || VMS */
  1686.  
  1687. /*
  1688.  * End of operating-system specific code.
  1689.  */
  1690. #endif                    /* StackPic */
  1691.